home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / advsys.arc / BASIC.ADI < prev    next >
Text File  |  1986-01-11  |  9KB  |  402 lines
  1. ; This is the simple runtime package
  2. ; by David Betz
  3. ; January 11, 1985
  4.  
  5. ; ********************
  6. ; PROPERTY DEFINITIONS
  7. ; ********************
  8.  
  9. ; These properties will be used for connections between locations
  10. (property
  11.   north            ; the location to the north
  12.   south            ; the location to the south
  13.   east            ; the location to the east
  14.   west            ; the location to the west
  15.   up            ; the location above
  16.   down)            ; the location below
  17.  
  18. ; Basic object properties
  19. (property
  20.   initial-location    ; the initial location of a "thing"
  21.   description        ; the "long" description of a location
  22.   short-description)    ; the "short" description of a location
  23.  
  24. ; Connection properties
  25. (property
  26.   parent        ; the parent of an object
  27.   sibling        ; the next sibling of an object
  28.   child)        ; the first child of an object
  29.  
  30. ; **********************
  31. ; VOCABULARY DEFINITIONS
  32. ; **********************
  33.  
  34. ; Some abbreviations for common commands
  35. (synonym north n)
  36. (synonym south s)
  37. (synonym east e)
  38. (synonym west w)
  39. (synonym inventory i)
  40.  
  41. ; Define the basic vocabulary
  42. (conjunction and)
  43. (article the that)
  44.  
  45. ; ********************
  46. ; VARIABLE DEFINITIONS
  47. ; ********************
  48.  
  49. (variable
  50.   curloc        ; the location of the player character
  51.   %actor        ; the actor object
  52.   %dobject        ; the direct object
  53.   %iobject)        ; the indirect object
  54.  
  55. ; ************************
  56. ; OBJECT CLASS DEFINITIONS
  57. ; ************************
  58.  
  59. ; The "basic-thing" class
  60. (object basic-thing
  61.   (property
  62.     parent nil        ; the parent of this object
  63.     sibling nil))    ; the next sibling of this object
  64.  
  65. ; The "location" object class
  66. (object location
  67.   (property
  68.     child nil        ; the first object in this location
  69.     visited nil))    ; has the player been here yet?
  70.  
  71. ; The "actor" class
  72. (basic-thing actor
  73.   (property
  74.     child nil))        ; the first "thing" carried by this actor
  75.  
  76. ; The "thing" class (things that can be taken)
  77. (basic-thing thing
  78.   (class-property
  79.     takeable t))
  80.  
  81. ; The "stationary-thing" class (things that can't be moved)
  82. (basic-thing stationary-thing)
  83.  
  84. ; *********************
  85. ; CONNECTION PRIMITIVES
  86. ; *********************
  87.  
  88. ; Connect an object to a parent
  89. (define (connect p c)
  90.   (setp c parent p)
  91.   (setp c sibling (getp p child))
  92.   (setp p child c))
  93.  
  94. ; Connect all objects to their initial parents
  95. (define (connect-all &aux obj maxp1 par)
  96.   (setq obj 1)
  97.   (setq maxp1 (+ $ocount 1))
  98.   (while (< obj maxp1)
  99.     (if (setq par (getp obj initial-location))
  100.       (connect par obj))
  101.     (setq obj (+ obj 1))))
  102.  
  103. ; Disconnect an object from its current parent
  104. (define (disconnect obj &aux this prev)
  105.   (setq this (getp (getp obj parent) child))
  106.   (setq prev nil)
  107.   (while this
  108.     (if (= this obj)
  109.       (progn
  110.     (if prev
  111.       (setp prev sibling (getp this sibling))
  112.       (setp (getp this parent) child (getp this sibling)))
  113.     (setp this parent nil)
  114.     (return)))
  115.     (setq prev this)
  116.     (setq this (getp this sibling))))
  117.  
  118. ; Disconnect and reconnect an object to a new parent
  119. (define (putin c p)
  120.   (if (getp c parent)
  121.       (disconnect c))
  122.   (connect p c))
  123.  
  124. ; Check to see if an object is the child of another object
  125. (define (isin? c p)
  126.   (= (getp c parent) p))
  127.  
  128. ; ***********************
  129. ; MISCELLANEOUS FUNCTIONS
  130. ; ***********************
  131.  
  132. ; Cause an object to travel an a specified direction
  133. (define (travel obj dir &aux loc)
  134.   (if (and (setq loc (getp obj parent))
  135.            (setq loc (getp loc dir)))
  136.     (progn
  137.       (disconnect obj)
  138.       (connect loc obj)
  139.       T)))
  140.  
  141. ; Print the contents of an object (used by "look")
  142. (define (print-contents obj prop &aux desc)
  143.   (setq obj (getp obj child))
  144.   (while obj
  145.     (if (setq desc (getp obj prop))
  146.       (progn
  147.     (print " ")
  148.     (print desc)))
  149.     (setq obj (getp obj sibling))))
  150.  
  151. ; List the contents of an object (used for "inventory")
  152. (define (list-contents obj prop &aux desc)
  153.   (setq obj (getp obj child))
  154.   (while obj
  155.     (if (setq desc (getp obj prop))
  156.       (progn
  157.     (print "\t")
  158.     (print desc)
  159.     (terpri)))
  160.     (setq obj (getp obj sibling))))
  161.  
  162. ; Complain about a noun phrase
  163. (define (complain head n tail)
  164.   (print head)
  165.   (print-noun n)
  166.   (print tail)
  167.   (abort))
  168.  
  169. ; Find an object in a location
  170. (define (findobject loc n &aux this found)
  171.   (setq this (getp loc child))
  172.   (setq found nil)
  173.   (while this
  174.     (if (match this n)
  175.       (if found
  176.         (complain "I don't know which " n " you mean!\n")
  177.     (setq found this)))
  178.     (setq this (getp this sibling)))
  179.   found)
  180.  
  181. ; Find an object in the player's current location
  182. ;  (or in the player's inventory)
  183. (define (in-location n &aux obj)
  184.   (if (or (setq obj (findobject curloc n))
  185.           (setq obj (findobject %actor n)))
  186.     obj
  187.     (complain "I don't see a " n " here!\n")))
  188.  
  189. ; Find an object in the player's inventory
  190. ;  (or in the player's current location)
  191. (define (in-pocket n &aux obj)
  192.   (if (or (setq obj (findobject %actor n))
  193.           (setq obj (findobject curloc n)))
  194.     obj
  195.     (complain "You don't have a " n "!\n")))
  196.  
  197. ; Get the short description of an object
  198. ;  (or the long description if there is no short one)
  199. (define (get-short-description loc &aux dsc)
  200.   (if (setq dsc (getp loc short-description))
  201.     dsc
  202.     (getp loc description)))
  203.  
  204. ; Print the long description of a location
  205. (define (print-long-description loc)
  206.   (print (getp loc description))
  207.   (print-contents loc description))
  208.  
  209. ; Look around a location
  210. ;  (print the long description if the player hasn't been here before
  211. ;   otherwise, print the short description)
  212. (define (look-around loc)
  213.   (if (getp loc visited)
  214.     (print (get-short-description loc))
  215.     (print-long-description loc))
  216.   (setp loc visited T)
  217.   (terpri))
  218.  
  219. ; Cause an actor to move in the specified direction
  220. (define (move dir)
  221.   (if (not (travel %actor dir))
  222.     (print "There is no exit in that direction.\n")))
  223.  
  224. ; Cause an actor to take an object
  225. (define (take-it act obj)
  226.   (putin obj act))
  227.  
  228. ; Cause an actor to drop an object
  229. (define (drop-it act obj)
  230.   (putin obj curloc))
  231.  
  232. ; ***************
  233. ; ACTION DEFAULTS
  234. ; ***************
  235.  
  236. (default
  237.   (actor optional))
  238.  
  239. ; ******************
  240. ; ACTION DEFINITIONS
  241. ; ******************
  242.  
  243. (action look
  244.   (verb look)
  245.   (code
  246.     (print-long-description curloc)
  247.     (terpri)))
  248.  
  249. (action take
  250.   (verb take get (pick up))
  251.   (direct-object)
  252.   (code
  253.     (setq %dobject (in-location $dobject))
  254.     (if (getp %dobject takeable)
  255.       (progn
  256.         (if (isin? %dobject %actor)
  257.           (complain "You are already carrying the " $dobject "!\n"))
  258.         (take-it %actor %dobject)
  259.         (print-noun $dobject)
  260.         (print " taken.\n"))
  261.       (complain "You can't take the " $dobject "!\n"))))
  262.  
  263. (action take-err
  264.   (verb take get (pick up))
  265.   (code
  266.     (print "Take what?\n")))
  267.  
  268. (action drop
  269.   (verb drop (put down))
  270.   (direct-object)
  271.   (code
  272.     (setq %dobject (in-pocket $dobject))
  273.     (if (isin? %dobject %actor)
  274.       (progn
  275.         (drop-it %actor %dobject)
  276.     (print-noun $dobject)
  277.     (print " dropped.\n"))
  278.       (complain "You aren't carrying the " $dobject "!\n"))))
  279.  
  280. (action drop-err
  281.   (verb drop (put down))
  282.   (code
  283.     (print "Drop what?\n")))
  284.  
  285. (action give
  286.   (verb give)
  287.   (direct-object)
  288.   (preposition to)
  289.   (indirect-object)
  290.   (code
  291.     (setq %dobject (in-pocket $dobject))
  292.     (setq %iobject (in-location $iobject))
  293.     (if (isin? %dobject %actor)
  294.       (progn
  295.         (drop-it %actor %dobject)
  296.         (take-it %iobject %dobject)
  297.     (print-noun $dobject)
  298.     (print " given.\n"))    
  299.       (complain "You aren't carrying the " $dobject "!\n"))))
  300.  
  301. (action give-err
  302.   (verb give)
  303.   (direct-object optional)
  304.   (code
  305.     (if $dobject
  306.       (complain "Give the " $dobject " to who?\n"))
  307.       (print "Give what?\n")))
  308.  
  309. (action inventory
  310.   (verb inventory)
  311.   (code
  312.     (cond ((getp %actor child)
  313.            (print "You are carrying:\n")
  314.            (list-contents %actor short-description))
  315.           (T (print "You are empty-handed.\n")))))
  316.  
  317. ; *********************
  318. ; GAME CONTROL COMMANDS
  319. ; *********************
  320.  
  321. (action save
  322.   (verb save)
  323.   (code
  324.     (save)))
  325.  
  326. (action restore
  327.   (verb restore)
  328.   (code
  329.     (restore)))
  330.  
  331. (action restart
  332.   (verb restart)
  333.   (code
  334.     (restart)))
  335.  
  336. (action quit
  337.   (verb quit)
  338.   (code
  339.     (print "Are you sure you want to quit? ")
  340.     (if (yes-or-no)
  341.       (exit))))
  342.  
  343. ; **************
  344. ; TRAVEL ACTIONS
  345. ; **************
  346.  
  347. (action go-north
  348.   (verb north (go north))
  349.   (code
  350.     (move north)))
  351.  
  352. (action go-south
  353.   (verb south (go south))
  354.   (code
  355.     (move south)))
  356.  
  357. (action go-east
  358.   (verb east (go east))
  359.   (code
  360.     (move east)))
  361.  
  362. (action go-west
  363.   (verb west (go west))
  364.   (code
  365.     (move west)))
  366.  
  367. (action go-up
  368.   (verb up (go up))
  369.   (code
  370.     (move up)))
  371.  
  372. (action go-down
  373.   (verb down (go down))
  374.   (code
  375.     (move down)))
  376.  
  377. ; *******************
  378. ; HANDLER DEFINITIONS
  379. ; *******************
  380.  
  381. (init
  382.   (connect-all)
  383.   (print welcome)
  384.   (setq curloc nil))
  385.  
  386. (update
  387.   (if (not (= (getp adventurer parent) curloc))
  388.     (progn
  389.       (setq curloc (getp adventurer parent))
  390.       (look-around curloc))))
  391.  
  392. (before
  393.   (setq %actor adventurer)
  394.   (if $actor
  395.     (progn
  396.       (setq %actor (in-location $actor))
  397.       (if (not (= (class %actor) actor))
  398.         (complain "You can't talk to a " $actor "!\n")))))
  399.  
  400.  
  401.  
  402.